perm filename WLDMOD.BAK[AL,HE] blob sn#390160 filedate 1978-10-21 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	EXTERNAL RPTR(GASSIGN) PROCEDURE NEW_GASSIGN(RVAR VINTEGER OP
C00009 ENDMK
C⊗;
EXTERNAL RPTR(GASSIGN) PROCEDURE NEW_GASSIGN(RVAR V;INTEGER OP;
					RPTR(CALCULATOR) C);
EXTERNAL RPTR(ALSODO) PROCEDURE NEW_ALSODO(RVAR V;INTEGER OP;
					RPTR(CHANGER) C);
EXTERNAL PROCEDURE DO_UNFIX(ITEMVAR OW;RANY F1,F2;REFERENCE RCELL GPHCODE);
EXTERNAL PROCEDURE DO_AFFIX(ITEMVAR OW;RANY F1,F2,BV;REXPR AE;RVAR RGF;
			    REFERENCE RCELL GPHCODE);

INTERNAL RPTR(GASSIGN) PROCEDURE NEW_GASSIGN(RVAR V;INTEGER OP;
					RPTR(CALCULATOR) C);
	BEGIN
	RPTR(GASSIGN) GA;
	GA←NEW_RECORD(GASSIGN);
	GASSIGN:VAR[GA]←V;
	GASSIGN:OP[GA]←OP;
	GASSIGN:CLC[GA]←C;
	RETURN(GA);
	END;

INTERNAL RPTR(ALSODO) PROCEDURE NEW_ALSODO(RVAR V;INTEGER OP;
					RPTR(CHANGER) C);
	BEGIN
	RPTR(ALSODO) ADO;
	ADO←NEW_RECORD(ALSODO);
	ALSODO:VAR[ADO]←V;
	ALSODO:OP[ADO]←OP;
	ALSODO:CHG[ADO]←C;
	RETURN(ADO);
	END;
! do_affix, do_affix_stmnt, do_unfix;

INTERNAL PROCEDURE DO_UNFIX(ITEMVAR OW;RANY F1,F2;REFERENCE RCELL GPHCODE);
	BEGIN
	RPTR(EXPRN,VARIABLE) BYEX;
	RPTR(AFXDATA) AD;
	RVAR RGF;

	IF RECTYPE(F1) = LOC(EXPRN) THEN F1 ← ARRAYREF(F1,OW);
	IF RECTYPE(F2) = LOC(EXPRN) THEN F2 ← ARRAYREF(F2,OW);

	IF LPMATCH(OW,\(AFFIXED,$ F1,$ F2,BIND BYEX,BIND RGF) ) THEN
		BEGIN
		DENYF(OW,_FACT_);
		AD←AFXDGET(F1,F2,BYEX,FALSE);
		IF RGF=RIGIDLY THEN
			BEGIN
			IF AFXDATA:T[AD]=BYEX THEN
				BYEX←AFXDATA:INVT[AD]
			ELSE
				BYEX←AFXDATA:T[AD];
			LPDENY(OW,\(AFFIXED,$ F2,$ F1,BYEX,RIGIDLY) );
			REMCALC(OW,F1,AFXDATA:C1[AD]);
			REMCALC(OW,F2,AFXDATA:C2[AD]);
			CONSON(NEW_GASSIGN(F2,2,AFXDATA:C2[AD]),GPHCODE);
			END
		ELSE
			BEGIN
			RPTR(ALSODO) ADO;
			REMCALC(OW,F1,AFXDATA:C1[AD]);
			REMCHG(OW,F1,AFXDATA:CHG[AD]);
! should kill old one!;	CONSON(NEW_ALSODO(F1,2,AFXDATA:CHG[AD]),GPHCODE);
			END;
		CONSON(NEW_GASSIGN(F1,2,AFXDATA:C1[AD]),GPHCODE);
		END;
	END;

INTERNAL PROCEDURE DO_AFFIX(ITEMVAR OW;RANY F1,F2,BV;REXPR AE;RVAR RGF;
			    REFERENCE RCELL GPHCODE);
	BEGIN
	RANY ASTN;
	RPTR(TRANS) T;
	RPTR(AFXDATA) AD;
	RPTR(VARIABLE) BVV;
	RPTR(BLOCK) BID;
	RPTR(ASSIGNMENT) ASG;

	IF RECTYPE(F1) = LOC(EXPRN) THEN F1 ← ARRAYREF(F1,OW);
	IF RECTYPE(F2) = LOC(EXPRN) THEN F2 ← ARRAYREF(F2,OW);
	IF RECTYPE(BV) = LOC(EXPRN) THEN BV ← ARRAYREF(BV,OW);

	DO_UNFIX(OW,F1,F2,GPHCODE);
	AD←AFXDGET(F1,F2,BV,TRUE);

	IF AE=NULL_RECORD THEN
		AE←NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
		   LIST2(NEW_EXPRN(TRANS_DTYPE,TINVRT_OP,CONS(F2,NULL_RECORD)),F1));
			! FTOF(F2,F1);
	VCHANGE(BV,EVALEXPR(AE,OW),OW);

	BID←VARIABLE:BLK[AFXDATA:YOUNGEST[AD]];
	LPASRT(OW,\(AFFIXED,$ F1, $ F2, $ BV, $ RGF));
	IF AFXDATA:C1[AD]=NULL_RECORD THEN
		BEGIN
		AFXDATA:C1[AD]←ASGLBL(NEW_LBL(ANY,CLCLAB_DTYPE,BID),
				BLDCALC(OW,NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
						  LIST2(F2,BV) ),BID));
		END;
	CONSON(NEW_GASSIGN(F1,1,AFXDATA:C1[AD]),GPHCODE);
	ADDCALC(OW,F1,AFXDATA:C1[AD]);
	IF RGF=RIGIDLY THEN
		BEGIN
		IF AFXDATA:INVT[AD]=NULL_RECORD THEN
			BEGIN
			AFXDATA:INVT[AD]←NEW_EXPRN(TRANS_DTYPE,
						   TINVRT_OP,CONS(BV,NULL_RECORD));
			AFXDATA:C2[AD]←ASGLBL(NEW_LBL(ANY,CLCLAB_DTYPE,BID),
					BLDCALC(OW,NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
					   LIST2(F1,AFXDATA:INVT[AD])),BID));
			END;
		CONSON(NEW_GASSIGN(F2,1,AFXDATA:C2[AD]),GPHCODE);
		LPASRT(OW,\(AFFIXED,$ F2,$ F1,$ AFXDATA:INVT[AD], RIGIDLY));
		ADDCALC(OW,F2,AFXDATA:C2[AD]);
		END
	ELSE
		BEGIN
		RPTR(ALSODO) ADO;
		IF AFXDATA:CHG[AD]=NULL_RECORD THEN
			BEGIN
			RVAR FF2; ! to get around a SAIL lossage;
			RPTR(ASSIGNMENT) ASG;
			FF2←F2;
			ASG←NEW_RECORD(ASSIGNMENT);
			ASSIGNMENT:VAR[ASG]←BV;
			ASSIGNMENT:VAL[ASG]←NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
				   LIST2(NEW_EXPRN(TRANS_DTYPE,TINVRT_OP,
						   CONS(FF2,NULL_RECORD)),
								VNEWTRANS) );
			AFXDATA:CHG[AD]←ASGLBL(NEW_LBL(ANY,CHGLAB_DTYPE,BID),
					       BLDCHG(STMAKE(ASG),BID));
			END;
		ADO←NEW_RECORD(ALSODO);
		ALSODO:VAR[ADO]←F1;ALSODO:OP[ADO]←1;
		ALSODO:CHG[ADO]←AFXDATA:CHG[AD];
		ADDCHG(OW,F1,AFXDATA:CHG[AD]);
		CONSON(ADO,GPHCODE);
		END;
	ASG←NEW_RECORD(ASSIGNMENT);
	ASSIGNMENT:VAR[ASG]←BV;
	ASSIGNMENT:VAL[ASG]←AE;
	CONSON(ASG,GPHCODE);
	END;